home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 5_2007-2008.ISO / data / Zips / Use_of_DWM20936612122007.psc / dwm glas / Mod_ThemeText.bas < prev    next >
BASIC Source File  |  2007-09-21  |  4KB  |  122 lines
  1. Attribute VB_Name = "Mod_ThemeText"
  2. Public Type FA_Type_DWM_ThemeText
  3.         Caption As String
  4.         ForeColor As Long
  5.         BackColor As Long
  6.         GlowSize As Integer
  7.         GlowColor As Long
  8.         Font As StdFont
  9.         
  10.         Top As Integer
  11.         Left As Integer
  12.         Width As Integer
  13.         Height As Integer
  14.         
  15.         hWnd As Long
  16.         hFont As Long
  17.         hFont_Old As Long
  18.         hTheme As Long
  19.         hDC_Dest As Long
  20.         hDC_Src As Long
  21.         BMP_Src As Long
  22.         BMP_Src_Old As Long
  23.         BMP_Dest As Long
  24.         BMP_Dest_Old As Long
  25.         IsCustomDC As Boolean
  26. End Type
  27.  
  28. Option Explicit
  29.  
  30. Public Function FA_ThemeText_Draw(Obj As FA_Type_DWM_ThemeText)
  31.  
  32. Dim AreaRect As RECT
  33. Dim DTT_Opts As DTTOPTS
  34. Dim DIB As BITMAPINFO
  35.  
  36. Obj.hTheme = OpenThemeData(Obj.hWnd, StrPtr("Window"))
  37. If (Not Obj.IsCustomDC) Then Obj.hDC_Dest = GetDC(Obj.hWnd)
  38. Obj.hDC_Src = CreateCompatibleDC(Obj.hDC_Dest)
  39.    
  40. With AreaRect
  41.         .Left = Obj.GlowSize
  42.         .Top = 0
  43.         .Right = Obj.Width
  44.         .Bottom = Obj.Height
  45. End With
  46.    
  47. With DIB.bmiHeader
  48.         .biSize = Len(DIB)
  49.         .biWidth = Obj.Width
  50.         .biHeight = -Obj.Height
  51.         .biPlanes = 1
  52.         .biBitCount = 32
  53.         .biCompression = 0
  54. End With
  55.  
  56. If (SaveDC(Obj.hDC_Src) <> 0) And (SaveDC(Obj.hDC_Dest) <> 0) Then
  57.         Obj.BMP_Src = CreateDIBSection(Obj.hDC_Src, DIB, 0, 0, 0, 0)
  58.         Obj.BMP_Dest = CreateDIBSection(Obj.hDC_Dest, DIB, 0, 0, 0, 0)
  59.         If (Obj.BMP_Src <> 0) And (Obj.BMP_Dest <> 0) Then
  60.                 Obj.BMP_Src_Old = SelectObject(Obj.hDC_Src, Obj.BMP_Src)
  61.                 Obj.BMP_Dest_Old = SelectObject(Obj.hDC_Dest, Obj.BMP_Dest)
  62.                 Obj.hFont = FA_ThemeText_hFont_Get(Obj.Font, Obj.hDC_Src)
  63.                 Obj.hFont_Old = SelectObject(Obj.hDC_Src, Obj.hFont)
  64.                 With DTT_Opts
  65.                         .crText = Obj.ForeColor
  66.                         .dwSize = Len(DTT_Opts)
  67.                         .dwFlags = DTT_COMPOSITED Or DTT_GLOWSIZE Or DTT_TEXTCOLOR
  68.                         .iGlowSize = Obj.GlowSize
  69.                 End With
  70.                 DrawThemeTextEx Obj.hTheme, Obj.hDC_Src, 0, 0, StrPtr(Obj.Caption), -1, DT_TEXTFORMAT, AreaRect, DTT_Opts
  71.                 BitBlt Obj.hDC_Dest, Obj.Left, Obj.Top, Obj.Width, Obj.Height, Obj.hDC_Src, 0, 0, vbSrcCopy
  72.         End If
  73. End If
  74.  
  75. End Function
  76.  
  77. Private Function FA_ThemeText_hFont_Get(ByRef TheFont As StdFont, ByVal hDC As Long) As Long
  78.  
  79. Dim TheLF As LOGFONT
  80. FA_ThemeText_OLEFontToLogFont TheFont, hDC, TheLF
  81. FA_ThemeText_hFont_Get = CreateFontIndirect(TheLF)
  82.  
  83. End Function
  84.  
  85. Private Sub FA_ThemeText_OLEFontToLogFont(ByRef ThisFont As StdFont, ByVal hDC As Long, ByRef TheLF As LOGFONT)
  86.  
  87. Dim sFont As String
  88. Dim iChar As Integer
  89. Dim ByteArray() As Byte
  90.  
  91. With TheLF
  92.      
  93.      sFont = ThisFont.Name
  94.      ByteArray = StrConv(sFont, vbFromUnicode)
  95.      
  96.      For iChar = 1 To Len(sFont)
  97.         .lfFaceName(iChar - 1) = ByteArray(iChar - 1)
  98.      Next iChar
  99.      
  100.      .lfHeight = -MulDiv((ThisFont.size), (GetDeviceCaps(hDC, LOGPIXELSY)), 72)
  101.      .lfItalic = ThisFont.Italic
  102.      
  103.      If (ThisFont.Bold) Then
  104.        .lfWeight = FW_BOLD
  105.      Else
  106.        .lfWeight = FW_NORMAL
  107.      End If
  108.      
  109.      .lfUnderline = ThisFont.Underline
  110.      .lfStrikeOut = ThisFont.Strikethrough
  111.      .lfCharSet = ThisFont.Charset
  112.  
  113. End With
  114.  
  115. End Sub
  116.  
  117. Public Sub FA_ThemeText_Refresh(Obj As FA_Type_DWM_ThemeText)
  118.  
  119. BitBlt Obj.hDC_Dest, Obj.Left, Obj.Top, Obj.Width, Obj.Height, Obj.hDC_Src, 0, 0, vbSrcCopy
  120.  
  121. End Sub
  122.